Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/scheme/boxer/boxer.lha/pbox.lisp

Text File | 1993-07-17 | 45.2 KB | 1,129 lines

;;; -*-Package: (PBOX GLOBAL 1000); Base:8.; Mode:lisp-*-

;;; (C) Copyright 1983 Massachusetts Institute of Technology
;;;
;;; Permission to use, copy, modify, distribute, and sell this software
;;; and its documentation for any purpose is hereby granted without fee,
;;; provided that the above copyright notice appear in all copies and that
;;; both that copyright notice and this permission notice appear in
;;; supporting documentation, and that the name of M.I.T. not be used in
;;; advertising or publicity pertaining to distribution of the software
;;; without specific, written prior permission.  M.I.T. makes no
;;; representations about the suitability of this software for any
;;; purpose.  It is provided "as is" without express or implied warranty.
;;;
;;; serial character printer for boxes.
;;; this code is meant to run in both MacLisp and Zetalisp.

;;; The box printer is divided into several parts.  The printer prints
;;; printable-box-objects, which are generated by the preprocessor.  The
;;; preprocessor itself is divided into two parts, the reader (which reads box
;;; files and conses up a printable-box-object, assuming no constraints), and
;;; the fitter, sometimes referred to in what follows as Procrustes, which
;;; operates on the printable-box-object and outputs a list of
;;; printable-box-objects, each of which is guaranteed to fit within the width
;;; of a page and be self-consistent.  The fitter has a list of tools, some of
;;; which are the exporter and the breaker (not implemented).  The printer is
;;; called by the page generator, which outputs individual pages, does
;;; formfeeds, numbers the boxes and pages, etc.

;;; In order to make this run in MacLisp, I define a string datatype, which is a
;;; list whose second member is the symbol STRING, first member a tail-pointer
;;; (for STRING-NCONC) and the rest of which is a series of fixnums representing
;;; the characters in the string.  STRING comes second, not first, because it
;;; becomes hard to print empty strings when the tail pointer contains the tail
;;; pointer.  The normal MacLisp excuse for strings is not used, because it
;;; would involve a great deal of copying.

#M
(DEFMACRO STRINGP (STRING)
    ;;validate the tail pointer somewhat, but don't take too long.
    `(IF (AND (LISTP ,STRING) (CAR ,STRING) (LISTP (CAR ,STRING))
          (CDR ,STRING) (EQ (CADR ,STRING) 'STRING))
     T
       NIL))

#M
(DEFUN STRING-LENGTH (STRING)
    (IF (STRINGP STRING) (LENGTH (CDDR STRING))
      (FERROR NIL "The argument to STRING-LENGTH, ~S was not a string."
          STRING)))

#M
(DEFUN STRING (OBJECT)
    (COND ((STRINGP OBJECT) OBJECT)
      ((SYMBOLP OBJECT) (LEXPR-FUNCALL #'MAKE-STRING (EXPLODEN OBJECT)))
      ((FIXNUMP OBJECT) (MAKE-STRING OBJECT))
      (T (FERROR NIL "The argument to STRING, ~S, cannot be coerced ~
to a string." OBJECT))))

;;; to be called from code that's already done the type-check
#M
(DEFMACRO TAIL-POINTER (STRING)
    `(CAR ,STRING))

#Q
(DEFMACRO TAIL-POINTER (STRING)
    `(STRING-LENGTH ,STRING))

#M
(DEFMACRO SET-TAIL-POINTER (STRING LIST)
    `(SETF (TAIL-POINTER ,STRING) ,LIST))

;;; return a pointer to the beginning of a string.
#M
(DEFUN START-POINTER (STRING)
    (IF (STRINGP STRING) (CDR STRING)
      (FERROR NIL "The argument to START-POINTER, ~S, was not a string."
          STRING)))

#Q
(DEFMACRO START-POINTER (IGNORE) 0)

#M
(DEFMACRO CHAR-AT-POINTER (POINTER IGNORE)
    `(CADR ,POINTER))

#Q
(DEFMACRO CHAR-AT-POINTER (POINTER STRING)
    `(AREF ,STRING ,POINTER))

(DEFMACRO GET-CHAR-AND-ADVANCE-POINTER (POINTER STRING)
  `(PROG1 (CHAR-AT-POINTER ,POINTER ,STRING)
      (ADVANCE-POINTER ,POINTER)))

(DEFUN POINTER-POINTS-TO-END? (POINTER STRING)
  (IF (STRINGP STRING) (EQ POINTER (TAIL-POINTER STRING))
    (FERROR NIL "The second argument to POINTER-POINTS-TO-END?, ~S,
was not a string." STRING)))

#M
(DEFMACRO ADVANCE-POINTER (POINTER)
    `(SETQ ,POINTER (CDR ,POINTER)))

#Q
(DEFMACRO ADVANCE-POINTER (POINTER)
    `(INCF ,POINTER))

#M
(DEFUN MAKE-STRING (&REST ELEMENTS)
    ;; make sure all the elements are fixnums.
    (DO ((ELEMENTS ELEMENTS (CDR ELEMENTS)))
    ((NULL ELEMENTS))
      (IF (NOT (FIXNUMP (CAR ELEMENTS)))
      (FERROR NIL "One of the arguments to MAKE-STRING, ~S, was ~
not a fixnum." (CAR ELEMENTS))))
      ;; okay to return a REST list in MacLisp.
    (LET ((NEW-STRING (CONS NIL (CONS 'STRING ELEMENTS))))
      ;; calling LAST on elements would break if no elements.
      (SET-TAIL-POINTER NEW-STRING (LAST NEW-STRING))
      NEW-STRING))

#Q
(DEFUN MAKE-STRING (&REST ELEMENTS)
    ;; make sure all the elements are characters
    (DO ((ELEMENTS ELEMENTS (CDR ELEMENTS)))
    ((NULL ELEMENTS))
      (IF (NOT (FIXNUMP (CAR ELEMENTS)))
      (FERROR NIL "The object ~S is not a fixnum." (CAR ELEMENTS))))
    (LET* ((LENGTH (LENGTH ELEMENTS))
       (STRING (MAKE-ARRAY LENGTH ':TYPE 'ART-STRING
                   ':LEADER-LIST (LIST LENGTH))))
    (FILLARRAY STRING ELEMENTS)))      ;FILLARRAY returns STRING

#M
(DEFUN CHARACTER (STRING)
    (CHAR-AT-POINTER (START-POINTER STRING) STRING))

#M
(DEFUN STRING-EQUAL (STRING1 STRING2)
    (EQUAL (STRING STRING1) (STRING STRING2)))

#M
(DEFUN STRING-NCONC (STRING1 STRING2)
    (COND ((FIXNUMP STRING2)
       (LET ((NEW-TAIL (NCONS STRING2)))
         (RPLACD (TAIL-POINTER STRING1) NEW-TAIL)
         (SET-TAIL-POINTER STRING1 NEW-TAIL)))
      ((STRINGP STRING2)
       (RPLACD (TAIL-POINTER STRING1) (CDDR STRING2))
       (SET-TAIL-POINTER STRING1 (TAIL-POINTER STRING2)))
      (T (FERROR NIL "The second argument to STRING-NCONC, ~S, ~
was not a string or a fixnum."))))

;;; copies top-level elements.
#M
(DEFUN SUBLIST (LIST START &OPTIONAL END)
    (DO ((LIST (NTHCDR START LIST) (CDR LIST))
     (COUNT START (1+ COUNT))
     (NEW-LIST))
    ((NULL LIST) (NREVERSE NEW-LIST))
      (AND END (IF (= COUNT END) (RETURN (NREVERSE NEW-LIST))))
      (PUSH (CAR LIST) NEW-LIST)))

#M
(DEFUN SUBSTRING (STRING START &OPTIONAL END)
    (IF (NOT (STRINGP STRING))
    (FERROR NIL "The first argument to SUBSTRING, ~S, was not a string.")
      (LEXPR-FUNCALL #'MAKE-STRING (SUBLIST (CDDR STRING) START END))))

#M
(DEFUN TYO-STRING (STRING STREAM)
    (IF (NOT (STRINGP STRING))
    (FERROR NIL "The first argument to TYO-STRING, ~S, was not a string."
        STRING))
    (DO ((STRING (CDDR STRING) (CDR STRING)))
    ((NULL STRING))
      (TYO (CAR STRING) STREAM)))

#Q
(DEFMACRO TYO-STRING (STRING STREAM)
    `(PRINC ,STRING ,STREAM))


;;; The printer.  This code prints individual printable-box-objects, which look
;;; like this: (width row-list type height <anything else>).
;;; The printer assumes that the parameters for each printable-box-object are
;;; consistent with the contents of the box.  So, for example, it will break if
;;; you give it a printable-box-object that has inside it a printable-box-object
;;; that doesn't fit inside it.  Height is unnecessary for the printer.

(defvar *pbox-system-hacker* nil) ;controls error message printing.
(DEFVAR *BOX-UNSELECTABLE-AREA-CHAR* #\SPACE)
(DEFVAR *BOX-INPUTS-STRING* (STRING "->"))
(DEFVAR *BOX-LEFT-SIDE-CHAR* #/|)
(DEFVAR *BOX-RIGHT-SIDE-CHAR* #/|)
(DEFVAR *BOX-LEFT-MARGIN-WIDTH* 1)
(DEFVAR *BOX-RIGHT-MARGIN-WIDTH* 1)
(DEFVAR *BOX-TOP-CHAR* #/-)
(DEFVAR *BOX-BOTTOM-CHAR* #/-)
(DEFVAR *BOX-LEFT-CORNER-CHAR* #/+)
(DEFVAR *BOX-RIGHT-CORNER-CHAR* #/+)
(DEFVAR *INTER-BOX-SPACING* 1)          ;vertical spacing between boxes
(DEFVAR *BOX-IDENTIFIER-WIDTH* 4)      ;the number of a box on a page
(DEFVAR *PAGE-WIDTH* 80.)          ;default if printing to file
(DEFVAR *PAGE-HEIGHT* 70.)
(DEFVAR *BOX-MAXIMUM-WIDTH* (- *PAGE-WIDTH* *BOX-IDENTIFIER-WIDTH*))
;;; the 1- is for the header
(DEFVAR *BOX-MAXIMUM-HEIGHT* (1- (- *PAGE-HEIGHT* *INTER-BOX-SPACING*)))
(DEFVAR *BOX-MINIMUM-WIDTH* 4)          ;includes sides
(DEFVAR *BOX-MINIMUM-HEIGHT* 3)          ;includes top and bottom
;;; these settings give this for         +--+
;;; an empty box:                        |  |
;;;                                      +--+

;;; BOX-WIDTH returns the width of a box.
(DEFMACRO BOX-WIDTH (BOX)
  `(IF (STRINGP ,BOX) (STRING-LENGTH ,BOX)
     (CAR ,BOX)))

(DEFMACRO SET-BOX-WIDTH (BOX WIDTH)
  `(SETF (CAR ,BOX) ,WIDTH))

(DEFMACRO BOX-HEIGHT (BOX)
  `(IF (STRINGP ,BOX) 1
     (CADDDR ,BOX)))

(DEFMACRO SET-BOX-HEIGHT (BOX HEIGHT)
  `(SETF (CADDDR ,BOX) ,HEIGHT))

(DEFMACRO BOX-ROW-LIST (BOX)
  `(CADR ,BOX))

(DEFMACRO SET-BOX-ROW-LIST (BOX NEW-ROW-LIST)
  `(SETF (BOX-ROW-LIST ,BOX) ,NEW-ROW-LIST))

(DEFMACRO BOX-TYPE (BOX)
  `(CADDR ,BOX))

(DEFMACRO SET-BOX-TYPE (BOX TYPE)
  `(SETF (BOX-TYPE ,BOX) ,TYPE))

(DEFMACRO BOX-FIRST-ROW (BOX)
  `(CAR (BOX-ROW-LIST ,BOX)))

(DEFMACRO REMOVE-FIRST-ROW (BOX)
  `(SET-BOX-ROW-LIST ,BOX (CDR (BOX-ROW-LIST ,BOX))))

(DEFMACRO BOX-HAS-TOP? (BOX)
  `(AND (NOT (NULL (BOX-ROW-LIST ,BOX)))
    (EQ (BOX-FIRST-ROW ,BOX) 'TOP)))

(DEFMACRO SET-FIRST-BOX-ALREADY-PRINTED (BOXES)
  `(LET ((BOX (CAR ,BOXES)))
     (IF (NOT (STRINGP BOX)) (SETF (CDR BOX) NIL)
       (SETF (CAR ,BOXES) (LIST (BOX-WIDTH BOX))))))

(DEFMACRO ALREADY-PRINTED-BOX? (BOX)
  `(NULL (CDR ,BOX)))

(DEFMACRO BOX-ONLY-BOTTOM-TO-BE-PRINTED? (BOX)
  `(AND (NULL (BOX-ROW-LIST ,BOX)) (= 1 (BOX-HEIGHT ,BOX))))

(DEFMACRO BOX-ONLY-VSPACE-TO-BE-PRINTED? (BOX)
  `(AND (NULL (BOX-ROW-LIST ,BOX)) (> (BOX-HEIGHT ,BOX) 1)))

(DEFMACRO PRINT-EMPTY-LINE (BOX STREAM)
  `(PROGN (TYO *BOX-LEFT-SIDE-CHAR* ,STREAM)
      (TYO-N #\SPACE ,STREAM (- (BOX-WIDTH ,BOX) 2))
      (TYO *BOX-RIGHT-SIDE-CHAR* ,STREAM)))

(DEFMACRO PRINT-BOX-BOTTOM (BOX STREAM)
  `(PROGN (TYO *BOX-LEFT-CORNER-CHAR* ,STREAM)
      (TYO-N *BOX-BOTTOM-CHAR* ,STREAM (- (BOX-WIDTH ,BOX) 2))
      (TYO *BOX-RIGHT-CORNER-CHAR* ,STREAM)))

(DEFUN PRINT-BOX-TOP (BOX STREAM)
  (TYO *BOX-LEFT-CORNER-CHAR* STREAM)
  (TYO-STRING (BOX-TYPE BOX) STREAM)
  (TYO-N *BOX-TOP-CHAR* STREAM
     (- (BOX-WIDTH BOX) 2 (STRING-LENGTH (BOX-TYPE BOX))))
  (TYO *BOX-RIGHT-CORNER-CHAR* STREAM))

;;; TYO-N tyos N CHARs to STREAM.
(DEFUN TYO-N (CHAR STREAM N)
  (IF (MINUSP N) (FERROR NIL "The function TYO-N received the negative argument ~S for N.  The other
arguments were ~S for CHAR and ~S for STREAM."
             N CHAR STREAM))
  (DO ((I N (1- I))) ((ZEROP I))
     (TYO CHAR STREAM)))

;;; Call this to print a box at top level.  PRINT-BOX-LINE and
;;; PRINT-FIRST-ROW-LINE necessarily print one line at a time, whereas this
;;; function prints an entire box, vertically as well as horizontally.
(DEFUN PRINT-TOP-LEVEL-BOX (BOX STREAM)
  (IF (STRINGP BOX) (PROGN (TYO-STRING BOX STREAM) (TERPRI STREAM))
    (IF (OR (NULL BOX)              ;can't be nil
        (NOT (NUMBERP (BOX-WIDTH BOX)))      ;has to have a width
        (NULL (CDR BOX))          ;has to have a list of rows
        ;;there has to be something in that list (at least 'TOP)
        (NULL (BOX-ROW-LIST BOX)))
    (FERROR NIL "The first argument to PRINT-TOP-LEVEL-BOX, ~S, is
not a recognizable printable-box-object."
        BOX))
  (DO ((BOX-FINISHED? (PROG1 (PRINT-BOX-LINE BOX STREAM) (TERPRI STREAM))
              (PROG1 (PRINT-BOX-LINE BOX STREAM) (TERPRI STREAM))))
      (BOX-FINISHED?))))

;;; PRINT-BOX-LINE returns NIL if it has not yet finished printing a box, else
;;; non-NIL.  Prints the first line of a box, including the first lines of any
;;; boxes inside it.  Causes inferior boxes to be suitably modified; i.e.,
;;; the printed line is removed from each inferior box.
(DEFUN PRINT-BOX-LINE (BOX STREAM)
  (COND ((STRINGP BOX) (TYO-STRING BOX STREAM) T)
    ((ALREADY-PRINTED-BOX? BOX)
     (TYO-N *BOX-UNSELECTABLE-AREA-CHAR* STREAM (BOX-WIDTH BOX)) T)
    ((BOX-ONLY-BOTTOM-TO-BE-PRINTED? BOX)
     (PRINT-BOX-BOTTOM BOX STREAM) T)
    (T (IF (BOX-ONLY-VSPACE-TO-BE-PRINTED? BOX)
           (PRINT-EMPTY-LINE BOX STREAM)
         (PRINT-FIRST-ROW-LINE BOX STREAM))
       ;; after printing a line, take note that there's one less to print,
       ;; if the box will ever be seen again.
       (SET-BOX-HEIGHT BOX (1- (BOX-HEIGHT BOX)))
       NIL)))

;;; PRINT-FIRST-ROW-LINE prints the first line of the first row of a box, and
;;; then replaces all fully printed boxes in it with already-printed-boxes.
;;; Then, if it has fully printed every box in the row, it removes the row from
;;; the box.
(DEFUN PRINT-FIRST-ROW-LINE (BOX STREAM)
  (IF (OR (NULL (CDR BOX)) (NULL (BOX-ROW-LIST BOX)))
      (FERROR NIL "The printable-box-object ~S, which was the first argument
to the function PRINT-FIRST-ROW-LINE, has an unrecognizable first row."
          BOX))
  (IF (BOX-HAS-TOP? BOX)
      (PROGN (PRINT-BOX-TOP BOX STREAM) (REMOVE-FIRST-ROW BOX))
      ;; if we weren't printing a boxtop, print a row.  Start with
      ;; *BOX-LEFT-CHAR* and *BOX-LEFT-MARGIN-WIDTH*.
      (LET ((CHARS-ALREADY-PRINTED (+ 1 *BOX-LEFT-MARGIN-WIDTH*)))
    (TYO *BOX-LEFT-SIDE-CHAR* STREAM)
    (TYO-N #\SPACE STREAM *BOX-LEFT-MARGIN-WIDTH*)
    (DO ((WIDTH-TO-PRINT (- (BOX-WIDTH BOX) CHARS-ALREADY-PRINTED))
         (BOXES (BOX-FIRST-ROW BOX) (CDR BOXES))
         (ROW-FINISHED? T) (BOX-FINISHED?) (CURRENT-BOX))
        ((NULL BOXES) (TYO-N #\SPACE STREAM
                 (- WIDTH-TO-PRINT *BOX-RIGHT-MARGIN-WIDTH* 1))
              (TYO-N #\SPACE STREAM *BOX-RIGHT-MARGIN-WIDTH*)
              (TYO *BOX-RIGHT-SIDE-CHAR* STREAM)
              (IF ROW-FINISHED? (REMOVE-FIRST-ROW BOX)))
      (SETQ CURRENT-BOX (CAR BOXES)
        WIDTH-TO-PRINT (- WIDTH-TO-PRINT (BOX-WIDTH CURRENT-BOX))
        BOX-FINISHED?  (PRINT-BOX-LINE CURRENT-BOX STREAM)
        ROW-FINISHED? (AND ROW-FINISHED? BOX-FINISHED?))
      (IF BOX-FINISHED? (SET-FIRST-BOX-ALREADY-PRINTED BOXES))))))



;;; The preprocessor.  The preprocessor is divided into two parts, the reader
;;; (which reads box files and conses up a printable-box-object, assuming no
;;; constraints), and the fitter, sometimes referred to in what follows as
;;; Procrustes, which operates on the printable-box-object and outputs a list
;;; of printable-box-objects, each of which is guaranteed to fit within the
;;; width of a page and be self-consistent.  The fitter has a list of tools,
;;; some of which are the exporter and the breaker (not implemented).

;;; The reader.  The principal useful function in the reader is READ-BOX-FILE,
;;; which returns a list of self-consistent printable-box-objects.

;;; No delimiter string can be a non-terminal subset of another delimiter
;;; string.  This is to avoid reading further than the end of a delimiter, which
;;; we don't want to do so we can call READ on the file whenever we expect that
;;; there will be a READable object next.


(DEFCONST *BOX-FILE-START-BOX-STRING* #Q(MAKE-STRING BOXER:*STRT-BOX-CODE*)
                                  #M(MAKE-STRING #/[))
(DEFCONST *BOX-FILE-END-BOX-STRING* #Q(MAKE-STRING BOXER:*STOP-BOX-CODE*)
                                    #M(MAKE-STRING #/]))
(DEFCONST *BOX-FILE-START-ROW-STRING* #Q(MAKE-STRING BOXER:*STRT-ROW-CODE*)
                                      #M(MAKE-STRING #/{))
(DEFCONST *BOX-FILE-END-ROW-STRING* #Q(MAKE-STRING BOXER:*STOP-ROW-CODE*)
                                    #M(MAKE-STRING #/}))
(DEFCONST *BOX-FILE-FONT-SPEC-STRING* #Q(MAKE-STRING #\ROMAN-IV)
                      #M(MAKE-STRING #\RUBOUT #^X))
(DEFCONST *BOX-FILE-QUOTING-STRING* #Q(MAKE-STRING #\EQUIVALENCE)
                       #M(MAKE-STRING #^^))
(DEFCONST *BOX-FILE-INPUTS-STRING* #Q(MAKE-STRING BOXER:*INPUTS-CODE*)
                             #M(MAKE-STRING #^Y))
(DEFCONST *BOX-FILE-LABEL-STRING* #Q(MAKE-STRING BOXER:*LABELLING-CODE*)
                                  #M(MAKE-STRING #/:))

(DEFCONST *BOX-FILE-DELIMITERS*
      (LIST *BOX-FILE-START-BOX-STRING* *BOX-FILE-END-BOX-STRING*
        *BOX-FILE-START-ROW-STRING* *BOX-FILE-END-ROW-STRING*
        *BOX-FILE-QUOTING-STRING* *BOX-FILE-FONT-SPEC-STRING*
        *BOX-FILE-LABEL-STRING* *BOX-FILE-INPUTS-STRING*))

(DEFCONST *BOX-TYPE-PRETTY-NAMES*
      (LIST (CONS ':DOIT-BOX (STRING "")) ;the calls to STRING are for
        (CONS ':DATA-BOX (STRING "Data"))))      ;the benefit of MacLisp

(DEFCONST *THE-EMPTY-STRING* (STRING ""))

(DEFMACRO GET-PRETTY-TYPE-NAME (TYPE)
  `(LET ((PRETTY-NAME (CDR (ASSQ ,TYPE *BOX-TYPE-PRETTY-NAMES*))))
     (IF PRETTY-NAME PRETTY-NAME *THE-EMPTY-STRING*)))

(DEFMACRO PRINTABLE-BOX-OBJECT-WITHOUT-SIZE (ROWS TYPE)
  `(LIST NIL                  ;width
     (CONS 'TOP ,ROWS)          ;row-list
     (GET-PRETTY-TYPE-NAME ,TYPE)      ;type
     NIL                  ;height
     NIL))                  ;last-export-pointer

;;; get the thing after THING, jumping two at a time.  NIL if not found.
(DEFUN GET-NEXT (THING LIST)
  (COND ((NULL LIST) NIL)
    ((EQUAL THING (CAR LIST))
     (IF (NOT (NULL (CDR LIST))) (CADR LIST) NIL))
    (T (GET-NEXT THING (CDDR LIST)))))

;;; GREATEST returns the greatest result of the application of FUNCTION to each
;;; member of LIST.  > is used for the comparison.  0 is returned for the empty
;;; list.
(DEFUN GREATEST (FUNCTION LIST)
  (DO ((GREATEST-SO-FAR 0)
       (LIST LIST (CDR LIST)) (THIS))
      ((NULL LIST) GREATEST-SO-FAR)
    (SETQ THIS (FUNCALL FUNCTION (CAR LIST)))      ;no DO* in MacLisp.
    (IF (> THIS GREATEST-SO-FAR) (SETQ GREATEST-SO-FAR THIS))))

;;; SUM returns the sum of the results of the application of FUNCTION to LIST.
;;; 0 is returned if the list is empty.  PLUS is used for addition.
(DEFUN SUM (FUNCTION LIST)
  (DO ((SUM-SO-FAR 0)
       (LIST LIST (CDR LIST)))
      ((NULL LIST) SUM-SO-FAR)
    (SETQ SUM-SO-FAR (+ SUM-SO-FAR (FUNCALL FUNCTION (CAR LIST))))))

;;; I hate Maclisp.
#M
(DEFUN RCHAR (STREAM EOF-OPTION)
    (LET ((CHAR (TYI STREAM EOF-OPTION)))
      (IF (= CHAR -1) NIL CHAR)))

#Q
(DEFMACRO RCHAR (STREAM EOF-OPTION)
    `(TYI ,STREAM ,EOF-OPTION))

#Q
(DEFMACRO RLINE (STREAM)
    `(READLINE ,STREAM))

#M
(DEFMACRO RLINE (STREAM)
    `(PROG1 (READLINE ,STREAM)
        (IF (= (TYIPEEK NIL ,STREAM -1) #\LINEFEED)
        (TYI ,STREAM))))

;;; Return the character in STRING pointed to by POINTER, or if POINTER points
;;; to the end of STRING, read in a char from STREAM and NCONC it to string, and
;;; return it.  If EOF is encountered, simply returns NIL.  Does not advance
;;; POINTER.
(DEFUN GET-CHAR-STRING-OR-STREAM (STRING POINTER STREAM)
  ;; if at end of string read a char from stream
  (IF (POINTER-POINTS-TO-END? POINTER STRING)
      (LET ((CHAR (RCHAR STREAM NIL)))
    ;; if at EOF don't try to put at end of string.
    (IF (NOT (NULL CHAR)) (STRING-NCONC STRING CHAR))
    CHAR)
    ;; otherwise just return the one we're at.
    (CHAR-AT-POINTER POINTER STRING)))

(DEFMACRO GET-CHAR-STRING-OR-STREAM-AP (STRING POINTER STREAM)
  `(PROG1 (GET-CHAR-STRING-OR-STREAM ,STRING ,POINTER ,STREAM)
      (ADVANCE-POINTER ,POINTER)))

;;; WITH-OPEN-FILE doesn't exist in MacLisp.
#M
(DEFMACRO WITH-OPEN-FILE ((STREAM FILE OPTIONS) &BODY BODY)
    `(LET ((,STREAM NIL))
       (UNWIND-PROTECT (PROGN (SETQ ,STREAM (OPEN ,FILE ,OPTIONS)) . ,BODY)
               (CLOSE ,STREAM))))

;;; READ-BOX-FILE returns a list of printable box objects, assuming no
;;; constraints on width or height.
(DEFUN READ-BOX-FILE (FILE)
  (WITH-OPEN-FILE (FILE-IN-STREAM FILE 'IN)
    (READ-BOX-STREAM FILE-IN-STREAM)))

(DEFUN READ-BOX-STREAM (FILE-IN-STREAM)
  (MAPC #'CALCULATE-AND-SET-BOX-SIZE        ;set the size parameters of
    (PARSE-ROW-FROM-STREAM FILE-IN-STREAM)));each box

;;; PARSE-ROW-FROM-STREAM returns a list of printable box objects with NIL in
;;; their size fields and those of all subboxes.  Comment lines are ignored.
;;; Returns 'END if there are no more rows in the box.
;;; Note that some boxes returned may be strings.
(DEFUN PARSE-ROW-FROM-STREAM (STREAM)
  (DO ((DELIMITER T) (STRING) (ROW))
      ;; null delimiter means eof
      ((OR (NULL DELIMITER) (STRING-EQUAL DELIMITER *BOX-FILE-END-ROW-STRING*))
       (NREVERSE ROW))
    ;; returns two values
    (MULTIPLE-VALUE (DELIMITER STRING) (READ-STRING-UNTIL-DELIMITER-OR-EOF
                     STREAM *BOX-FILE-DELIMITERS*))
    (IF (STRING-EQUAL DELIMITER *BOX-FILE-END-BOX-STRING*)
    (IF (OR (NOT (NULL ROW)) (NOT (STRING-EQUAL STRING DELIMITER)))
        ;; if we got an end-box, and there was something before it, it's a
        ;; bug.
        (FERROR NIL "A box terminator was encountered in the middle ~
of the row ~S.
The string being read was ~S." (NREVERSE ROW) STRING)
        (RETURN 'END)))
    (LET ((SUBSTRING (SUBSTRING STRING 0
                (- (STRING-LENGTH STRING)
                   (IF (NULL DELIMITER) 0
                       (STRING-LENGTH DELIMITER))))))
      ;; if we immediately encountered a delimiter, don't keep the null string
      (IF (NOT (STRING-EQUAL SUBSTRING *THE-EMPTY-STRING*))
      (PUSH SUBSTRING ROW)))
    (COND ((STRING-EQUAL DELIMITER *BOX-FILE-START-BOX-STRING*)
       (PUSH (PARSE-BOX-FROM-STREAM STREAM) ROW))
      ((STRING-EQUAL DELIMITER *BOX-FILE-QUOTING-STRING*)
       (PUSH (STRING (TYI STREAM)) ROW))
      ((STRING-EQUAL DELIMITER *BOX-FILE-FONT-SPEC-STRING*)
       (TYI STREAM))
      ((string-equal delimiter *box-file-label-string*)
       (push *box-file-label-string* row))
      ((STRING-EQUAL DELIMITER *BOX-FILE-INPUTS-STRING*)
       (PUSH *BOX-INPUTS-STRING* ROW)))))

;;; PARSE-BOX-FROM-STREAM returns a printable box object read from the stream
;;; STREAM.  Call it AFTER consuming the begin-box string.
(DEFUN PARSE-BOX-FROM-STREAM (STREAM)
  (LET ((BOX-DESCRIPTOR (READ STREAM)))
    (IF (NOT (LISTP BOX-DESCRIPTOR))
    (FERROR NIL "The box descriptor ~S is not a list.
While reading a box from the stream ~S." BOX-DESCRIPTOR STREAM))
    (DO ((TYPE (GET-NEXT ':TYPE BOX-DESCRIPTOR))
     (ROW (PARSE-ROW-FROM-STREAM STREAM) (PARSE-ROW-FROM-STREAM STREAM))
     (ROW-LIST))
    ((EQ ROW 'END) (PRINTABLE-BOX-OBJECT-WITHOUT-SIZE
             (NREVERSE ROW-LIST) TYPE))
      (PUSH ROW ROW-LIST))))

;;; Read a string until encountering a delimiter string, and MVR the delimiter
;;; string and the string.
(DEFUN READ-STRING-UNTIL-DELIMITER-OR-EOF (STREAM DELIMITER-LIST)
  (LET* ((STRING (MAKE-STRING)) (POINTER (START-POINTER STRING)))
    (DO ((CHAR (GET-CHAR-STRING-OR-STREAM STRING POINTER STREAM)
           (GET-CHAR-STRING-OR-STREAM STRING POINTER STREAM)))
    ((NULL CHAR) (VALUES NIL STRING))
      (LET ((MATCH? (MATCH-ANY STRING POINTER STREAM DELIMITER-LIST)))
    (IF MATCH? (RETURN (VALUES MATCH? STRING))
      (ADVANCE-POINTER POINTER))))))

;;; try to match one of the strings in DELIMITER-LIST with the string and stream
;;; starting at POINTER.  Return NIL if lose, delimiter if won.
(DEFUN MATCH-ANY (STRING POINTER STREAM DELIMITER-LIST)
  (IF (NULL DELIMITER-LIST) NIL
    (LET* ((SELF (CAR DELIMITER-LIST)) (SELF-POINTER (START-POINTER SELF))
       (CHAR-POINTER POINTER))
      (DO ((CHAR (GET-CHAR-STRING-OR-STREAM-AP STRING CHAR-POINTER STREAM)
         (GET-CHAR-STRING-OR-STREAM-AP STRING CHAR-POINTER STREAM)))
      (NIL)
    ;;this will catch eof as well.
    (IF (EQ (GET-CHAR-AND-ADVANCE-POINTER SELF-POINTER SELF) CHAR)
        (IF (POINTER-POINTS-TO-END? SELF-POINTER SELF)
        (RETURN SELF))
      (RETURN (MATCH-ANY STRING POINTER STREAM (CDR DELIMITER-LIST))))))))

(DEFMACRO MAYBE-BOX? (BOX)
  `(OR (STRINGP ,BOX)              ;a maybe-box is a string
       (AND (LISTP ,BOX)          ;or, more likely, a list
        (>= (LENGTH ,BOX) 4)      ;with at least 4 elements
        (LISTP (CADR ,BOX))          ;row-list has to be a list
        (STRINGP (CADDR ,BOX)))))      ;type has to be a string

;;; CALCULATE-AND-SET-BOX-SIZE actually calculates and changes all the WIDTH
;;; and HEIGHT fields in the box and all its subboxes.
(DEFUN CALCULATE-AND-SET-BOX-SIZE (BOX)
  ;; validate the type somewhat.
  (IF (NOT (MAYBE-BOX? BOX))
      (FERROR NIL "The object ~S is not a recognizable box." BOX))
  (CALCULATE-AND-SET-BOX-WIDTH BOX)
  (CALCULATE-AND-SET-BOX-HEIGHT BOX))

;;; Sets and returns BOX-WIDTH for this box and all subboxes.  Does no type
;;; check on BOX.
(DEFUN CALCULATE-AND-SET-BOX-WIDTH (BOX)
  (IF (STRINGP BOX) (STRING-LENGTH BOX)      ;don't set a string's width
    (LET ((BOX-WIDTH
        ;;the width of a box is the greatest of
        (MAX
          ;; the sum of the widths of its sides, margins, and widest row,
          (+ *BOX-RIGHT-MARGIN-WIDTH* *BOX-LEFT-MARGIN-WIDTH* 2
         (IF (NOT (BOX-HAS-TOP? BOX))
             (FERROR NIL "~
The printable-box-object ~S, which was the first argument to
CALCULATE-AND-SET-BOX-WIDTH, has no top." BOX)
           (GREATEST #'SET-AND-GET-ROW-WIDTH
                 ;; don't consider the boxtop.
                 (CDR (BOX-ROW-LIST BOX)))))
          ;; the sum of the widths of its label and sides
          (+ (STRING-LENGTH (BOX-TYPE BOX)) 2)
          ;; and the minumum box width.
          *BOX-MINIMUM-WIDTH*)))
      (SET-BOX-WIDTH BOX BOX-WIDTH)
      BOX-WIDTH)))

;;; Set the width of each box in the row ROW (and all subboxes) and return the
;;; sum of their widths.
(DEFUN SET-AND-GET-ROW-WIDTH (ROW)
  ;; width of empty row being 0 follows from definition of SUM
  (SUM #'CALCULATE-AND-SET-BOX-WIDTH ROW))

;;; Sets and returns BOX-HEIGHT for this box and all subboxes.  Does no type
;;; check on BOX.
(DEFUN CALCULATE-AND-SET-BOX-HEIGHT (BOX)
  (IF (STRINGP BOX) 1              ;don't set a string's height
    (LET ((BOX-HEIGHT (MAX *BOX-MINIMUM-HEIGHT*
               (+ (IF (NOT (BOX-HAS-TOP? BOX))
                  (FERROR NIL "~
The printable-box-object ~S, which was the first argument to
CALCULATE-AND-SET-BOX-HEIGHT, has no top." BOX)
                (SUM #'SET-AND-GET-ROW-HEIGHT
                     ;; don't consider the boxtop.
                     (CDR (BOX-ROW-LIST BOX))))
                  2))))
      (SET-BOX-HEIGHT BOX BOX-HEIGHT)
      BOX-HEIGHT)))

;;; Set the height of each box in ROW (and all subboxes) and return the
;;; greatest of their heights.
(DEFUN SET-AND-GET-ROW-HEIGHT (ROW)
  (IF (EQ ROW NIL) 1              ;the empty row is 1 tall.
    (GREATEST #'CALCULATE-AND-SET-BOX-HEIGHT ROW)))



;;; The fitter, or Procrustes.

;;; The fitter has a list of functions to call on a box which is too large to
;;; be printed.  It calls them sequentially until one works.  Each fitting
;;; function is expected to accept a list whose first member is the
;;; printable-box-object to be fitted; the rest is the rest of the boxes to be
;;; printed.  This is so the exporter can put the boxes it exports somewhere
;;; (like immediately after the box it exports them from).  Each fitting
;;; function is also expected to accept as second and third arguments the
;;; maximum width and height of a box.  If a fitting function decides that it
;;; cannot cure the problem, it returns NIL.  All fitting functions work by
;;; mutating the list they have been handed.

(DEFVAR *BOX-FITTING-FUNCTIONS* NIL)

;;; returns the box-list, suitably modified.
(DEFUN FIT (BOX-LIST &OPTIONAL (FITTERS *BOX-FITTING-FUNCTIONS*))
  (DO ((BOXES BOX-LIST (CDR BOXES)) (BOX))
      ((NULL BOXES) BOX-LIST)
    (SETQ BOX (CAR BOXES))
    (IF (OR (> (BOX-WIDTH BOX) *BOX-MAXIMUM-WIDTH*)
        (> (BOX-HEIGHT BOX) *BOX-MAXIMUM-HEIGHT*))
    (DO ((FITTING-FUNCTIONS FITTERS (CDR FITTING-FUNCTIONS)))
        ((NULL FITTING-FUNCTIONS)
         (NOTIFY-USER-ABOUT-BOX-FITTING-LOSSAGE box))
      (IF (FUNCALL (CAR FITTING-FUNCTIONS) BOXES *BOX-MAXIMUM-WIDTH*
               *BOX-MAXIMUM-HEIGHT*)
          (RETURN NIL))))))

(DEFUN NOTIFY-USER-ABOUT-BOX-FITTING-LOSSAGE (BOX)
  (IF (NULL *PBOX-SYSTEM-HACKER*)
      (FORMAT T "~%A box of width ~D and height ~D is too big to fit on the page."
          (BOX-WIDTH BOX)
          (box-height box))
    (LET ((PRINLEVEL 3)
      (PRINLENGTH 3))
      (FORMAT T
          "The printable-box-object ~S,
with width ~D and height ~D, cannot be mutated to fit within the
width (~D) and height (~D) of the page."
          BOX (BOX-WIDTH BOX) (BOX-HEIGHT BOX) *BOX-MAXIMUM-WIDTH*
          *BOX-MAXIMUM-HEIGHT*)
      (IF (NOT (Y-OR-N-P (FORMAT NIL "~%Continue anyway? ")))
      (BREAK "-- you lose")))))


;;; The exporter is the only fitting function implemented so far.  The exporter
;;; grovels over the first box in the box-list it is handed, first adjusting
;;; its width to fit, then adjusting its height.  Because these are done
;;; sequentially, the resulting configuration may actually be less wide than it
;;; has to be; that is, if a box is exported because it is too tall, it may
;;; happen that it is also on the widest row, so it may make the box thinner
;;; than need be.  A second pass should cure this.

;;; If this is a box, the exporter should only copy this object, never use it!
(DEFVAR *EXPORT-BOX-MODEL* (STRING "|pg 00,#00|"))

(DEFVAR *DO-EXPORTS-FOR-WIDTH* T)
(DEFVAR *DO-EXPORTS-FOR-HEIGHT* T)
(DEFVAR *BOX-MINIMUM-EXPORT-HEIGHT* 4)

(DEFMACRO EXPORT-PART (BOX)
  `(NTHCDR 5 ,BOX))

;;; Every printable-box-object has a part, the last-export-pointer, which
;;; comes after the height. Looks like:
;;; (WIDTH ROW-LIST TYPE HEIGHT LAST-EXPORT-POINTER . EXPORT-PART)
;;; While the export part is a backpointer from a box that has been exported to
;;; the place from which it was exported, the last-export-pointer is a pointer
;;; from a top-level box from which something has been exported to where the
;;; next thing should be exported to.  It is meant to aid in the ordering of
;;; export boxes.  If it is null, the next export should go immediately after
;;; this box; otherwise it's a pointer to the list that the last exported box
;;; started and the next export box should go after that box, and the
;;; last-export-pointer should be updated.  Since exports all happen in one
;;; pass, the result will be okay, even though the last-export-pointer of a box
;;; will no longer be good after things have been exported from one of its
;;; exports.

(DEFMACRO LAST-EXPORT-POINTER (BOX)
  `(CAR (CDDDDR ,BOX)))

(DEFMACRO SET-LAST-EXPORT-POINTER (BOX THING)
  `(SETF (LAST-EXPORT-POINTER ,BOX) ,THING))

(DEFUN EXPORT-SUBBOXES-IF-NECESSARY (BOX-LIST MAX-WIDTH MAX-HEIGHT)
  (IF (NULL BOX-LIST) (FERROR NIL
"The function EXPORT-SUBBOXES-IF-NECESSARY was given an empty box-list."))
  (LET ((BOX (CAR BOX-LIST)))
    ;; if the maximum width is less than the box-top width, can't fix.
    (IF (< MAX-WIDTH (+ 2 (STRING-LENGTH (BOX-TYPE BOX)))) NIL
      (AND (IF (> (BOX-WIDTH BOX) MAX-WIDTH)
           ;; this'll return NIL if it tries and loses
           (IF (NOT *DO-EXPORTS-FOR-WIDTH*) T
         (EXPORT-FOR-WIDTH BOX-LIST MAX-WIDTH))
         ;;T if there's no problem, because then it's solved.
         T)
       (IF (> (BOX-HEIGHT BOX) MAX-HEIGHT)
           ;; this'll return NIL if it tries and loses
           (IF (NOT *DO-EXPORTS-FOR-HEIGHT*) T
         (EXPORT-FOR-HEIGHT BOX-LIST MAX-HEIGHT))
         T)))))

(PUSH  #'EXPORT-SUBBOXES-IF-NECESSARY *BOX-FITTING-FUNCTIONS*)

(DEFMACRO EXPORTABLE? (BOX)
  `(AND (NOT (STRINGP ,BOX))
    (>= (BOX-HEIGHT ,BOX) *BOX-MINIMUM-EXPORT-HEIGHT*)))

;;; EXPORT-FOR-WIDTH attempts to export from the widest row the smallest single
;;; box that will cure the problem.  If no single box can be exported to cure
;;; the problem, the widest box on the row will be removed and the exporter
;;; will be called again.  [Note: in the plural case, this won't really find
;;; the best combination; it's just simple.  That is, there may be a pair of
;;; boxes that exactly cure the problem that don't include the largest box.]
(DEFUN EXPORT-FOR-WIDTH (BOX-LIST MAX-WIDTH)
  (LET* ((BOX (CAR BOX-LIST))
     (WIDTH-OVER-MAXIMUM (- (BOX-WIDTH BOX) MAX-WIDTH))
     (EXPORTABLE-WIDTH (+ (BOX-WIDTH *EXPORT-BOX-MODEL*)
                  WIDTH-OVER-MAXIMUM)))
    (IF (<= WIDTH-OVER-MAXIMUM 0) T
      (LET ((BEST-BOX-LIST
          (BOX-WITH-WIDTH-CLOSEST-TO
        EXPORTABLE-WIDTH (WIDEST-ROW-NOT-TOP BOX))))
    (IF BEST-BOX-LIST
        (LET ((BEST-WIDTH (BOX-WIDTH (CAR BEST-BOX-LIST))))
          (IF (>= BEST-WIDTH (BOX-WIDTH *EXPORT-BOX-MODEL*))
          (PROGN (EXPORT-IT BEST-BOX-LIST BOX-LIST)
             (CALCULATE-AND-SET-BOX-SIZE BOX)
             (EXPORT-FOR-WIDTH BOX-LIST MAX-WIDTH))
        NIL)))))))

;;; recursively walk the subboxes of a box and find the box with width closest
;;; to, but greater than or equal to, the width given, or if there are none
;;; greater than or equal to, the widest.  Strings are never considered.  NIL
;;; if no subboxes.  Returns the list that the box starts.
(DEFUN BOX-WITH-WIDTH-CLOSEST-TO (WIDTH BOX-LIST)
  (DO ((BOX-LIST BOX-LIST (CDR BOX-LIST))
       (CURRENT-WIDTH) (BEST-WIDTH 0) (BEST-BOX-LIST))
      ((NULL BOX-LIST) BEST-BOX-LIST)
    (IF (EXPORTABLE? (CAR BOX-LIST))
    (PROGN (SETQ CURRENT-WIDTH (BOX-WIDTH (CAR BOX-LIST)))
           ;; if the current box is better than the best so far
           (IF (SORT-OF-CLOSER? CURRENT-WIDTH BEST-WIDTH WIDTH)
           ;; make it the best box
           (SETQ BEST-WIDTH CURRENT-WIDTH BEST-BOX-LIST BOX-LIST))
           (LET ((BEST-SUBBOX-LIST
               (BOX-WITH-WIDTH-CLOSEST-TO
             WIDTH (WIDEST-ROW-NOT-TOP (CAR BOX-LIST)))))
         ;; if there is a best subbox
         (AND BEST-SUBBOX-LIST
              ;;and it's better than the best so far
              (IF (SORT-OF-CLOSER? (BOX-WIDTH (CAR BEST-SUBBOX-LIST))
                       BEST-WIDTH WIDTH)
              ;; then it's the best box
              (SETQ BEST-BOX-LIST BEST-SUBBOX-LIST
                BEST-WIDTH
                (BOX-WIDTH (CAR BEST-SUBBOX-LIST))))))))))

;;; if CURRENT-QUANTITY is closer to QUANTITY than BEST-QUANTITY is, return t,
;;; else nil; but use a strange definition for closer.  If both
;;; CURRENT-QUANTITY and BEST-QUANTITY are smaller or greater than QUANTITY,
;;; then the one actually closer is correct; but if one is over and one under,
;;; the one over is preferred.
(DEFUN SORT-OF-CLOSER? (CURRENT-QUANTITY BEST-QUANTITY QUANTITY)
  (IF (>= BEST-QUANTITY QUANTITY)
      ;; if best-quantity over the desired, then current-quantity
      ;; has to be between it and desired to be better.
      (>= BEST-QUANTITY CURRENT-QUANTITY QUANTITY)
    ;; if best-quantity less than desired, current-quantity need
    ;; only be bigger to be better.
    (> CURRENT-QUANTITY BEST-QUANTITY)))

;;; returns NIL if no rows beside top
(DEFUN WIDEST-ROW-NOT-TOP (BOX)
  (LET ((ROW-LIST (IF (BOX-HAS-TOP? BOX) (CDR (BOX-ROW-LIST BOX))
            (BOX-ROW-LIST BOX))))
    (DO ((ROW-LIST ROW-LIST (CDR ROW-LIST))
     (CURRENT-ROW) (CURRENT-WIDTH) (WIDEST-ROW) (WIDEST-WIDTH 0))
    ((NULL ROW-LIST) WIDEST-ROW)
      (SETQ CURRENT-ROW (CAR ROW-LIST)
        CURRENT-WIDTH (ROW-WIDTH CURRENT-ROW))
      (IF (> CURRENT-WIDTH WIDEST-WIDTH)
      (SETQ WIDEST-ROW CURRENT-ROW WIDEST-WIDTH CURRENT-WIDTH)))))

(DEFUN ROW-WIDTH (ROW)
  (IF (NOT (OR (LISTP ROW) (NULL ROW))) (FERROR NIL
"The function ROW-WIDTH was given the value ~S, which should have
been a list, for ROW." ROW))
  (DO ((WIDTH 0 (+ WIDTH (BOX-WIDTH (CAR BOX-LIST))))
       (BOX-LIST ROW (CDR BOX-LIST)))
      ((NULL BOX-LIST) WIDTH)))

#M
(DEFUN COPYTREE (TREE)
    (IF (OR (STRINGP TREE)          ;for MacLisp "strings"
        (NOT (LISTP TREE))) TREE
      (MAPCAR #'COPYTREE TREE)))

;;;; symbol conflict
;(EVAL-WHEN (LOAD COMPILE)
;  (SHADOW 'EXPORT)
;  )   ;; this didn't work, I'm just going to change the name of the
;      ;; function

;;; actually replace the given box with an export box, add a pointer from the
;;; export box to the pointer, put the export box in the right place, and reset
;;; the last-export-pointer of the box.
(DEFUN EXPORT-IT (LIST-THAT-BOX-STARTS BOX-LIST)
  (LET ((BOX (CAR LIST-THAT-BOX-STARTS)))
    ;; remember that before printing this PAGIFY-BOX-LIST must be run on the
    ;; list to replace the model with the real thing.
    (SETF (CAR LIST-THAT-BOX-STARTS) *EXPORT-BOX-MODEL*)
    ;;; if the box has no last-export-pointer yet, give it one.
    (IF (NULL (LAST-EXPORT-POINTER BOX))
    (SET-LAST-EXPORT-POINTER BOX BOX-LIST))
    ;; the exported box goes in the cdr of the last-export-pointer, i.e., after
    ;; the last box expoted from this box.
    (LET ((NEW-EXPORT-POINTER (CONS BOX (CDR (LAST-EXPORT-POINTER BOX)))))
      (SETF (CDR (LAST-EXPORT-POINTER BOX)) NEW-EXPORT-POINTER)
      ;; then the last-export-pointer gets reset to point to the new last box
      ;; exported.
      (SET-LAST-EXPORT-POINTER BOX NEW-EXPORT-POINTER))
    ;; finally, set the back-pointer from the exported box to the export
    ;; pointer.
    (SETF (EXPORT-PART BOX) LIST-THAT-BOX-STARTS)))

(DEFUN EXPORT-FOR-HEIGHT (BOX-LIST MAX-HEIGHT)
  (LET* ((BOX (CAR BOX-LIST))
     (HEIGHT-OVER-MAXIMUM (- (BOX-HEIGHT BOX) MAX-HEIGHT)))
    (IF (<= HEIGHT-OVER-MAXIMUM 0) T
      (MULTIPLE-VALUE-BIND (BEST-BOX-LIST BEST-SAVING)
      (BOX-WITH-HEIGHT-SAVING-CLOSEST-TO
        HEIGHT-OVER-MAXIMUM (CDR (BOX-ROW-LIST BOX)))
    (IF BEST-BOX-LIST
        (IF (>= BEST-SAVING HEIGHT-OVER-MAXIMUM)
        (PROGN (EXPORT-IT BEST-BOX-LIST BOX-LIST)
               (CALCULATE-AND-SET-BOX-SIZE BOX))
          (IF (> (BOX-HEIGHT (CAR BEST-BOX-LIST))
             (BOX-HEIGHT *EXPORT-BOX-MODEL*))
          (PROGN (EXPORT-IT BEST-BOX-LIST BOX-LIST)
             (CALCULATE-AND-SET-BOX-SIZE BOX)
             (EXPORT-FOR-HEIGHT BOX-LIST MAX-HEIGHT)))))))))

;;; recursively determine the box or subbox in this row-list whose exportation
;;; would result in a reduction in height (of the box) closest to the quantity
;;; HEIGHT.  MVRs the list the box starts and amount saved or NIL if none.
(DEFUN BOX-WITH-HEIGHT-SAVING-CLOSEST-TO (HEIGHT ROW-LIST)
  (DO ((ROW-LIST ROW-LIST (CDR ROW-LIST))
       (CURRENT-SAVING) (CURRENT-SUBLIST) (BEST-SAVING 0) (BEST-SUBLIST))
      ((NULL ROW-LIST) (VALUES BEST-SUBLIST BEST-SAVING))
    (MULTIPLE-VALUE (CURRENT-SUBLIST CURRENT-SAVING)
      (HEIGHT-SAVING-BOX (CAR ROW-LIST)))
    (IF CURRENT-SUBLIST
    (PROGN (IF (SORT-OF-CLOSER? CURRENT-SAVING BEST-SAVING HEIGHT)
           (SETQ BEST-SAVING CURRENT-SAVING
             BEST-SUBLIST CURRENT-SUBLIST))
           (MULTIPLE-VALUE-BIND (BEST-SUBBOX-SUBLIST BEST-SUBBOX-SAVING)
           (BOX-WITH-HEIGHT-SAVING-CLOSEST-TO
             HEIGHT (CDR (BOX-ROW-LIST (CAR CURRENT-SUBLIST))))
         (AND BEST-SUBBOX-SUBLIST
              (IF (SORT-OF-CLOSER? BEST-SUBBOX-SAVING BEST-SAVING
                       HEIGHT)
              (SETQ BEST-SAVING BEST-SUBBOX-SAVING
                BEST-SUBLIST BEST-SUBBOX-SUBLIST))))))))

;;; find the box whose removal would decrease this row's height and return the
;;; list it starts and the amount that would be saved.
(DEFUN HEIGHT-SAVING-BOX (ROW)
  (DO ((BOX-LIST ROW (CDR BOX-LIST))
       (TALLEST-SUBLIST) (TALLEST-HEIGHT 0) (NEXT-TALLEST-SUBLIST)
       (NEXT-TALLEST-HEIGHT 0) (CURRENT-HEIGHT))
      ((NULL BOX-LIST)
       ;; only one box ever decreases the height of a row, so check here.
       (IF (AND TALLEST-SUBLIST (EXPORTABLE? (CAR TALLEST-SUBLIST)))
       (VALUES TALLEST-SUBLIST
           (- TALLEST-HEIGHT NEXT-TALLEST-HEIGHT))
     NIL))
    (SETQ CURRENT-HEIGHT (BOX-HEIGHT (CAR BOX-LIST)))
    (IF (> CURRENT-HEIGHT TALLEST-HEIGHT)
    (PSETQ TALLEST-SUBLIST BOX-LIST TALLEST-HEIGHT CURRENT-HEIGHT
           NEXT-TALLEST-SUBLIST TALLEST-SUBLIST
           NEXT-TALLEST-HEIGHT TALLEST-HEIGHT)
      (IF (> CURRENT-HEIGHT NEXT-TALLEST-HEIGHT)
      (SETQ NEXT-TALLEST-SUBLIST BOX-LIST
        NEXT-TALLEST-HEIGHT CURRENT-HEIGHT)))))

;;; The page generator.
#M
(DEFVAR STANDARD-OUTPUT T)
(DEFCONST *PAGE-END-STRING* (STRING #Q (FORMAT NIL "~|")
                    #M #^L))

;;; print a box list to a stream.  If no stream, standard-output.
(DEFUN PRINT-BOX-LIST (BOX-LIST WHERE)
  (DO ((BOX-LIST BOX-LIST (CDR BOX-LIST))
       (BOX-NUMBER 1))
      ((NULL BOX-LIST))
    (IF (STRINGP (CAR BOX-LIST))
    (PROGN (TYO-STRING (CAR BOX-LIST) WHERE)
           (TERPRI WHERE)
           (IF (STRING-EQUAL (CAR BOX-LIST) *PAGE-END-STRING*)
           (SETQ BOX-NUMBER 1)))
      (DO ((BOX-FINISHED?
         ;; print the box number, with a ". " after, enough padding
         ;; before to have a total of *BOX-INDENTIFIER-WIDTH*
         ;; characters.
         (PROG2 (TYO-STRING
              (STRING (FORMAT NIL "~VD. "
                      (- *BOX-IDENTIFIER-WIDTH* 2)
                      BOX-NUMBER))
              WHERE)
            ;; and a line of the box
            (PRINT-BOX-LINE (CAR BOX-LIST) WHERE)
            ;; then a CR
            (TERPRI WHERE))
         (PROG2 (TYO-N #\SPACE WHERE *BOX-IDENTIFIER-WIDTH*)
            (PRINT-BOX-LINE (CAR BOX-LIST) WHERE)
            (TERPRI WHERE))))
      (BOX-FINISHED?))
      (SETQ BOX-NUMBER (1+ BOX-NUMBER)))))

;;; keeps the first cons the same.
(DEFUN PUSH+ (THING CONS)
  (IF (OR (NOT (LISTP CONS)) (NULL CONS))
      (FERROR NIL
          "The function PUSH+ was given a second argument of ~S, which was
of the wrong type.  The function expected a cons." CONS))
  (LET ((NEWCDR (NCONS (CAR CONS))))
    (RPLACD NEWCDR (CDR CONS))
    (RPLACA CONS THING)
    (RPLACD CONS NEWCDR)))

;;; Being for the benefit of Mr. Maclisp FORMAT.
#M (DEFUN UNSTRINGIFY (STRING)
     (IF (NOT (STRINGP STRING)) (FERROR NIL "The argument to UNSTRINGIFY, ~S,~
was not a string." STRING)
       (IMPLODE (CDDR STRING))))

(DEFUN PAGIFY-BOX-LIST (BOX-LIST PAGE-WIDTH PAGE-HEIGHT LEFT-HEADER RIGHT-HEADER)
  ;; make sure both left and right headers are same length so FORMAT wins
  (COND ((> (STRING-LENGTH LEFT-HEADER) (STRING-LENGTH RIGHT-HEADER))
     (SETQ RIGHT-HEADER
           (STRING (FORMAT NIL "~VX~A" (- (STRING-LENGTH LEFT-HEADER)
                          (STRING-LENGTH RIGHT-HEADER))
                   #M (UNSTRINGIFY RIGHT-HEADER)
                   #Q RIGHT-HEADER))))
    ((> (STRING-LENGTH RIGHT-HEADER) (STRING-LENGTH LEFT-HEADER))
     (SETQ LEFT-HEADER
           (STRING (FORMAT NIL "~A~VX" #M (UNSTRINGIFY LEFT-HEADER)
                   #Q LEFT-HEADER
                   (- (STRING-LENGTH RIGHT-HEADER)
                  (STRING-LENGTH LEFT-HEADER)))))))
  (DO ((BOXES BOX-LIST) (PAGE 1 (1+ PAGE)))
      ((NULL BOXES) BOX-LIST)
    ;; insert the header and an empty line
    (PUSH+ (STRING (FORMAT NIL "~V<~A~;-~D-~;~A~>" PAGE-WIDTH
               #M (UNSTRINGIFY LEFT-HEADER) #Q LEFT-HEADER
               PAGE
               #M (UNSTRINGIFY RIGHT-HEADER) #Q RIGHT-HEADER))
       BOXES)
    ;; now cdr down the list of boxes until no more will fit on the page,
    ;; inserting vertical spacing between them.
    (DO ((SPACING *THE-EMPTY-STRING*) (BOX)
     (LINES-LEFT (1- PAGE-HEIGHT)
             (- LINES-LEFT
            (+ *INTER-BOX-SPACING* (BOX-HEIGHT BOX))))
     (BOX-NUMBER 1 (1+ BOX-NUMBER))
     (BOXES-MAYBE-ON-THIS-PAGE (CDR BOXES) (CDR BOXES-MAYBE-ON-THIS-PAGE)))
    ((OR (NULL BOXES-MAYBE-ON-THIS-PAGE)
         (> (+ *INTER-BOX-SPACING*
           (BOX-HEIGHT (CAR BOXES-MAYBE-ON-THIS-PAGE)))
        LINES-LEFT))
     (SETQ BOXES BOXES-MAYBE-ON-THIS-PAGE))
      (SETQ BOX (CAR BOXES-MAYBE-ON-THIS-PAGE))
      ;; insert the spacing
      (DO ((I *INTER-BOX-SPACING* (1- I))) ((ZEROP I))
    (PUSH+ SPACING BOXES-MAYBE-ON-THIS-PAGE))
      ;; jump over it
      (SETQ BOXES-MAYBE-ON-THIS-PAGE
        (NTHCDR *INTER-BOX-SPACING* BOXES-MAYBE-ON-THIS-PAGE))
      ;; update the export pointer (if there) to point to this box's location.
      (IF (AND (NOT (STRINGP BOX)) (EXPORTED? BOX))
      (MAKE-EXPORT-POINTER-POINT-TO-BOX BOX PAGE BOX-NUMBER)))
    ;; now insert a page-break unless at end of the list (and thus file)
    (IF BOXES (PROGN (PUSH+ *PAGE-END-STRING* BOXES)
             (SETQ BOXES (CDR BOXES))))))

(DEFUN USERNAME-STRING ()
  (STRING #Q FS:USER-PERSONAL-NAME-FIRST-NAME-FIRST
      #M (STATUS UNAME)))

(DEFUN FILENAME-STRING (STRING)
  (STRING (WITH-OPEN-FILE (PATHNAME STRING)
        #M(NAMESTRING (TRUENAME PATHNAME))
        #Q(FUNCALL (FUNCALL PATHNAME ':TRUENAME) ':STRING-FOR-PRINTING))))

(DEFUN PRINT-BOXES-FROM-FILE (FROM-FILE &OPTIONAL TO-FILE)
  (WITH-OPEN-FILE (FROM-STREAM FROM-FILE '(IN ASCII))
    (READLINE FROM-STREAM)            ;flush the comment
    (COND ((NOT (NULL TO-FILE))
       (WITH-OPEN-FILE (TO-STREAM TO-FILE '(OUT ASCII))
         (PRINT-BOXES-FROM-STREAM-TO-STREAM FROM-STREAM TO-STREAM
                        *PAGE-WIDTH* *PAGE-HEIGHT*
                        (USERNAME-STRING)
                        (FILENAME-STRING FROM-FILE))))
      (T
       (PRINT-BOXES-FROM-STREAM-TO-STREAM FROM-STREAM STANDARD-OUTPUT
                          *PAGE-WIDTH* *PAGE-HEIGHT*
                          (USERNAME-STRING)
                          (FILENAME-STRING FROM-FILE))))))

(DEFUN PRINT-BOXES-FROM-STREAM-TO-STREAM
       (FROM-STREAM TO-STREAM PAGE-WIDTH PAGE-HEIGHT UNAME FILENAME)
  (PRINT-BOX-LIST (PAGIFY-BOX-LIST (FIT (READ-BOX-STREAM FROM-STREAM))
                   PAGE-WIDTH PAGE-HEIGHT
                   UNAME FILENAME)
          TO-STREAM))

(DEFUN HARDCOPY-BOXER-FILE (PATHNAME)
  (WITH-OPEN-FILE (STREAM PATHNAME ':READ)
    (SI:HARDCOPY-FROM-STREAM STREAM SI:*DEFAULT-HARDCOPY-DEVICE* ':PAGE-HEADINGS NIL)))

#Q
(DEFUN HARDCOPY-BOX (BOX)
    (LET ((TEMP-PATHNAME-1
        (SEND (FS:USER-HOMEDIR) ':NEW-PATHNAME ':NAME "PBOX" ':TYPE "TEMP1"))
      (TEMP-PATHNAME-2
        (SEND (FS:USER-HOMEDIR) ':NEW-PATHNAME ':NAME "PBOX" ':TYPE "TEMP2")))
      (BOXER:OLD-WRITE-BOX-INTO-FILE BOX TEMP-PATHNAME-1)
      (PRINT-BOXES-FROM-FILE TEMP-PATHNAME-1 TEMP-PATHNAME-2)
      (HARDCOPY-BOXER-FILE TEMP-PATHNAME-2)
      (FS:DELETEF TEMP-PATHNAME-1)
      (FS:DELETEF TEMP-PATHNAME-2)
      ))


(DEFUN EXPORTED? (BOX)
  (IF (OR (STRINGP BOX) (NOT (MAYBE-BOX? BOX)))
      (FERROR NIL "The function EXPORTED? received as argument the object ~S, ~
which is~% not a box." BOX))
  (EXPORT-PART BOX))

(DEFUN MAKE-EXPORT-POINTER-POINT-TO-BOX (BOX PAGE BOX-NUMBER)
  (SETF (CAR (EXPORT-PART BOX))
    (STRING (FORMAT NIL "|pg ~2D,#~2D|" PAGE BOX-NUMBER))))

;;; Call this to idiot-proofly set the dimensions of the page or boxes.
(DEFUN SET-PRINTER-DIMENSIONS (PAGE-WIDTH &OPTIONAL PAGE-HEIGHT BOX-MAX-WIDTH
                   BOX-MAX-HEIGHT)
  ;; first set the width idiot-proofly.
  (COND ((AND (NULL PAGE-WIDTH) (NULL BOX-MAX-WIDTH))      ;neither width given
     (SETQ *PAGE-WIDTH* 100.)
     (SETQ *BOX-MAXIMUM-WIDTH* (- *PAGE-WIDTH* *BOX-IDENTIFIER-WIDTH*)))
    ((NULL BOX-MAX-WIDTH)          ;only page width given
     (SETQ *PAGE-WIDTH* PAGE-WIDTH)
     (SETQ *BOX-MAXIMUM-WIDTH* (- *PAGE-WIDTH* *BOX-IDENTIFIER-WIDTH*)))
    ((NULL PAGE-WIDTH)          ;only box width given
     (SETQ *BOX-MAXIMUM-WIDTH* BOX-MAX-WIDTH)
     (SETQ *PAGE-WIDTH* (+ *BOX-IDENTIFIER-WIDTH* *BOX-MAXIMUM-WIDTH*)))
    (T (IF (> BOX-MAX-WIDTH          ;both given - check consistency
          (- PAGE-WIDTH *BOX-IDENTIFIER-WIDTH*))
           (FERROR NIL "~
The values you have given for page width, ~D, and maximum box width, ~D, are
inconsistent with each other.  The maximum box width must be at least ~D less
than the page width." PAGE-WIDTH BOX-MAX-WIDTH *BOX-IDENTIFIER-WIDTH*)
         (SETQ *PAGE-WIDTH* PAGE-WIDTH
           *BOX-MAXIMUM-WIDTH* BOX-MAX-WIDTH))))
  (COND ((AND (NULL PAGE-HEIGHT) (NULL BOX-MAX-HEIGHT))      ;neither height given
     (SETQ *PAGE-HEIGHT* 70.)
     (SETQ *BOX-MAXIMUM-HEIGHT* (1- (- *PAGE-HEIGHT* *INTER-BOX-SPACING*))))
    ((NULL BOX-MAX-HEIGHT)          ;only page height given
     (SETQ *PAGE-HEIGHT* PAGE-HEIGHT)
     (SETQ *BOX-MAXIMUM-HEIGHT* (1- (- *PAGE-HEIGHT* *INTER-BOX-SPACING*))))
    ((NULL PAGE-HEIGHT)          ;only box height given
     (SETQ *BOX-MAXIMUM-HEIGHT* BOX-MAX-HEIGHT)
     (SETQ *PAGE-HEIGHT* (+ 1 *INTER-BOX-SPACING* *BOX-MAXIMUM-HEIGHT*)))
    (T (IF (> BOX-MAX-HEIGHT      ;both given - check consistency
          (1- (- PAGE-HEIGHT *INTER-BOX-SPACING*)))
           (FERROR NIL "~
The values you have given for page height, ~D, and maximum box height, ~D, are
inconsistent with each other.  The maximum box height IRst be at least ~D less
than the page height."
               PAGE-HEIGHT BOX-MAX-HEIGHT
               (1+ *INTER-BOX-SPACING*))
         (SETQ *PAGE-HEIGHT* PAGE-HEIGHT
           *BOX-MAXIMUM-HEIGHT* BOX-MAX-HEIGHT)))))